home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / elk-2_0.lha / elk-2.0 / examples / xm / message-dialog < prev    next >
Encoding:
Text File  |  1992-10-01  |  1.5 KB  |  50 lines
  1. ;;; -*-Scheme-*-
  2. ;;;
  3. ;;; Message box dialog demo
  4.  
  5. (require 'motif)
  6. (load-widgets shell message-box row-column toggle-button push-button)
  7. (load 'radio-stuff)
  8.  
  9. (define top (application-initialize 'message-box))
  10.  
  11. (define rc (create-managed-widget (find-class 'row-column) top))
  12.  
  13. (define box (create-radio-box 'push-button rc))
  14.  
  15. (define buttons
  16.   (map (lambda (label)
  17.      (radio-box-add-button! box 'label-string label
  18.                 'alignment "alignment_center"))
  19.   '(error information message question warning working)))
  20.  
  21. (for-each
  22.   (lambda (button)
  23.     (add-callback button 'activate-callback
  24.           (lambda _
  25.             (post-dialog (car (get-values button 'label-string))))))
  26.   buttons)
  27.  
  28. (define box2 (create-radio-box 'toggle-button rc 'radio-behavior #f))
  29.  
  30. (define ok (radio-box-add-button! box2 'label-string 'OK-button 'set #t))
  31. (define cancel (radio-box-add-button! box2 'label-string 'Cancel-button
  32.                       'set #t))
  33. (define help (radio-box-add-button! box2 'label-string 'Help-button 'set #t))
  34.  
  35. (define (post-dialog type)
  36.   (let* ((shell (create-popup-shell (find-class 'dialog-shell) rc))
  37.          (box (create-widget
  38.         (find-class 'message-box) shell
  39.         'dialog-type (string->symbol (string-append "dialog-" type)))))
  40.     (unless (car (get-values ok 'set))
  41.         (unmanage-child (name->widget box 'OK)))
  42.     (unless (car (get-values cancel 'set))
  43.         (unmanage-child (name->widget box 'Cancel)))
  44.     (unless (car (get-values help 'set))
  45.         (unmanage-child (name->widget box 'Help)))
  46.     (manage-child box)))
  47.  
  48. (realize-widget top)
  49. (context-main-loop (widget-context top))
  50.